home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _eacd8b3b6f0c55f05453751f3e07ff87 < prev    next >
Encoding:
Text File  |  2002-05-30  |  4.3 KB  |  185 lines
  1. package Tk::DragDrop::SunDrop;
  2. require  Tk::DragDrop::Rect;
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = '3.015'; # $Id: //depot/Tk8/DragDrop/DragDrop/SunDrop.pm#15 $
  6.  
  7. use base  qw(Tk::DragDrop::Rect);
  8. use strict;
  9. use Tk::DragDrop::SunConst;
  10.  
  11. Tk::DragDrop->Type('Sun');
  12.  
  13. BEGIN
  14.  {
  15.   my @fields = qw(name win X Y width height flags);
  16.   my $i = 0;
  17.   no strict 'refs';
  18.   for ($i=0; $i < @fields; $i++)
  19.    {
  20.     my $j    = $i;
  21.     *{"$fields[$i]"} = sub { shift->[$j] };
  22.    }
  23.  }
  24.  
  25. sub Preview
  26. {
  27.  my ($site,$token,$e,$kind,$flags) = (@_);
  28.  $token->BackTrace('No flags') unless defined $flags;
  29.  my $sflags = $site->flags;
  30.  return if ($kind == _motion && !($sflags & MOTION));
  31.  return if ($kind != _motion && !($sflags & ENTERLEAVE));
  32.  my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags);
  33.  $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data);
  34. }
  35.  
  36. sub Enter
  37. {
  38.  my ($site,$token,$e) = @_;
  39.  $token->AcceptDrop;
  40.  $site->Preview($token,$e,_enter,0);
  41. }
  42.  
  43. sub Leave
  44. {
  45.  my ($site,$token,$e) = @_;
  46.  $token->RejectDrop;
  47.  $site->Preview($token,$e,_leave,0);
  48. }
  49.  
  50. sub Motion
  51. {
  52.  my ($site,$token,$e) = @_;
  53.  $site->Preview($token,$e,_motion,0);
  54. }
  55.  
  56. sub HandleDone
  57. {
  58.  my ($token,$seln,$offset,$max) = @_;
  59.  $token->Done;
  60.  return '';
  61. }
  62.  
  63. sub HandleAck
  64. {
  65.  my ($w,$seln,$offset,$max) = @_;
  66.  return '';
  67. }
  68.  
  69. sub HandleItem
  70. {
  71.  my ($w,$seln,$offset,$max) = @_;
  72.  return undef;
  73. }
  74.  
  75. sub HandleCount
  76. {
  77.  my ($w,$seln,$offset,$max) = @_;
  78.  return 1;
  79. }
  80.  
  81. sub Drop
  82. {
  83.  my ($site,$token,$seln,$e) = @_;
  84.  my $w  = $token->parent;
  85.  $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]);
  86.  $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]);
  87.  my $atom  = $w->InternAtom($seln);
  88.  my $flags = ACK_FLAG | TRANSIENT_FLAG;
  89.  my $data  = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags);
  90.  $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data);
  91. }
  92.  
  93.  
  94. sub FindSite
  95. {
  96.  my ($class,$token,$X,$Y) = @_;
  97.  $token->{'SunDD'} = [] unless exists $token->{'SunDD'};
  98.  my $site = $class->SUPER::FindSite($token,$X,$Y);
  99.  if (!defined $site)
  100.   {
  101.    my $id = $token->PointToWindow($X,$Y);
  102.    while ($id)
  103.     {
  104.      my @prop;
  105.      Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) };
  106.      if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0)
  107.       {
  108.        my ($bx,$by) = $token->WindowXY($id);
  109.        $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'};
  110.        return $site if $token->{'SunDDSeen'}{$id};
  111.        $token->{'SunDDSeen'}{$id} = 1;
  112.        my $sites = $token->{'SunDD'};
  113.        my $count = shift(@prop);
  114.        while (@prop && $count-- > 0)
  115.         {
  116.          my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5);
  117.          if ($kind != 0)
  118.           {
  119.            warn "Don't understand site type $kind";
  120.            last;
  121.           }
  122.          while (@prop >= 4 && $n-- > 0)
  123.           {
  124.            my ($x,$y,$w,$h) = splice(@prop,0,4);
  125.            push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags],$class);
  126.           }
  127.         }
  128.        return $class->SUPER::FindSite($token,$X,$Y);
  129.       }
  130.      $id = $token->PointToWindow($X,$Y,$id)
  131.     }
  132.   }
  133.  return $site;
  134. }
  135.  
  136. my $busy = 0;
  137.  
  138. sub NewDrag
  139. {
  140.  my ($class,$token) = @_;
  141.  delete $token->{'SunDD'} unless $busy;
  142.  delete $token->{'SunDDSeen'};
  143. }
  144.  
  145. sub SiteList
  146. {
  147.  my ($class,$token) = @_;
  148.  # this code is obsolete now that we look at properties ourselves
  149.  # which means we don't need dropsite manager running
  150.  unless (1 || $busy || exists $token->{'SunDD'})
  151.   {
  152.    Carp::confess('Already doing it!') if ($busy++);
  153.    my @data  = ();
  154.    my @sites = ();
  155.    my $mw = $token->MainWindow;
  156.    $token->{'SunDD'} = \@sites;
  157.    Tk::catch {
  158.       @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM',  '_SUN_DRAGDROP_SITE_RECTS');
  159.    };
  160.    if ($@)
  161.     {
  162.      $token->configure('-cursor'=>'hand2');
  163.      $token->grab(-global);
  164.     }
  165.    else
  166.     {
  167.      while (@data)
  168.       {
  169.        my $version = shift(@data);
  170.        if ($version != 0)
  171.         {
  172.          warn "Unexpected site version $version";
  173.          last;
  174.         }
  175.        push(@sites,bless [splice(@data,0,7)],$class);
  176.       }
  177.     }
  178.    $busy--;
  179.   }
  180.  return @{$token->{'SunDD'}};
  181. }
  182.  
  183. 1;
  184. __END__
  185.